home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / w3 / url-gw.el.z / url-gw.el
Encoding:
Text File  |  1998-05-21  |  8.7 KB  |  260 lines
  1. ;;; url-gw.el --- Gateway munging for URL loading
  2. ;; Author: wmperry
  3. ;; Created: 1997/10/22 16:44:36
  4. ;; Version: 1.10
  5. ;; Keywords: comm, data, processes
  6.  
  7. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  8. ;;; Copyright (c) 1997 Free Software Foundation, Inc.
  9. ;;;
  10. ;;; This file is not part of GNU Emacs, but the same permissions apply.
  11. ;;;
  12. ;;; GNU Emacs is free software; you can redistribute it and/or modify
  13. ;;; it under the terms of the GNU General Public License as published by
  14. ;;; the Free Software Foundation; either version 2, or (at your option)
  15. ;;; any later version.
  16. ;;;
  17. ;;; GNU Emacs is distributed in the hope that it will be useful,
  18. ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20. ;;; GNU General Public License for more details.
  21. ;;;
  22. ;;; You should have received a copy of the GNU General Public License
  23. ;;; along with GNU Emacs; see the file COPYING.  If not, write to the
  24. ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  25. ;;; Boston, MA 02111-1307, USA.
  26. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  27. (require 'cl)
  28.  
  29. (defgroup url-gateway nil
  30.   "URL gateway variables"
  31.   :group 'url)
  32.  
  33. (defcustom url-gateway-local-host-regexp nil
  34.   "*A regular expression specifying local hostnames/machines."
  35.   :type '(choice (const nil) regexp)
  36.   :group 'url-gateway)
  37.  
  38. (defcustom url-gateway-prompt-pattern
  39.   "^[^#$%>;]*[#$%>;] *" ;; "bash\\|\$ *\r?$\\|> *\r?"
  40.   "*A regular expression matching a shell prompt."
  41.   :type 'regexp
  42.   :group 'url-gateway)
  43.  
  44. (defcustom url-gateway-rlogin-host nil
  45.   "*What hostname to actually rlog into before doing a telnet."
  46.   :type '(choice (const nil) string)
  47.   :group 'url-gateway)
  48.  
  49. (defcustom url-gateway-rlogin-user-name nil
  50.   "*Username to log into the remote machine with when using rlogin."
  51.   :type '(choice (const nil) string)
  52.   :group 'url-gateway)
  53.  
  54. (defcustom url-gateway-rlogin-parameters '("telnet" "-8")
  55.   "*Parameters to `url-open-rlogin'.
  56. This list will be used as the parameter list given to rsh."
  57.   :type '(repeat string)
  58.   :group 'url-gateway)
  59.  
  60. (defcustom url-gateway-telnet-host nil
  61.   "*What hostname to actually login to before doing a telnet."
  62.   :type '(choice (const nil) string)
  63.   :group 'url-gateway)
  64.  
  65. (defcustom url-gateway-telnet-parameters '("exec" "telnet" "-8")
  66.   "*Parameters to `url-open-telnet'.
  67. This list will be executed as a command after logging in via telnet."
  68.   :type '(repeat string)
  69.   :group 'url-gateway)
  70.  
  71. (defcustom url-gateway-telnet-login-prompt "^\r*.?login:"
  72.   "*Prompt that tells us we should send our username when loggin in w/telnet."
  73.   :type 'regexp
  74.   :group 'url-gateway)
  75.  
  76. (defcustom url-gateway-telnet-password-prompt "^\r*.?password:"
  77.   "*Prompt that tells us we should send our password when loggin in w/telnet."
  78.   :type 'regexp
  79.   :group 'url-gateway)
  80.  
  81. (defcustom url-gateway-telnet-user-name nil
  82.   "User name to log in via telnet with."
  83.   :type '(choice (const nil) string)
  84.   :group 'url-gateway)
  85.  
  86. (defcustom url-gateway-telnet-password nil
  87.   "Password to use to log in via telnet with."
  88.   :type '(choice (const nil) string)
  89.   :group 'url-gateway)
  90.  
  91. (defcustom url-gateway-broken-resolution nil
  92.   "*Whether to use nslookup to resolve hostnames.
  93. This should be used when your version of Emacs cannot correctly use DNS,
  94. but your machine can.  This usually happens if you are running a statically
  95. linked Emacs under SunOS 4.x"
  96.   :type 'boolean
  97.   :group 'url-gateway)
  98.  
  99. (defcustom url-gateway-nslookup-program "nslookup"
  100.   "*If non-NIL then a string naming nslookup program."
  101.   :type '(choice (const :tag "None" :value nil) string)
  102.   :group 'url-gateway)
  103.  
  104. ;; Stolen from ange-ftp
  105. ;;;###autoload
  106. (defun url-gateway-nslookup-host (host)
  107.   "Attempt to resolve the given HOSTNAME using nslookup if possible."
  108.   (interactive "sHost:  ")
  109.   (if url-gateway-nslookup-program
  110.       (let ((proc (start-process " *nslookup*" " *nslookup*"
  111.                  url-gateway-nslookup-program host))
  112.         (res host))
  113.     (process-kill-without-query proc)
  114.     (save-excursion
  115.       (set-buffer (process-buffer proc))
  116.       (while (memq (process-status proc) '(run open))
  117.         (accept-process-output proc))
  118.       (goto-char (point-min))
  119.       (if (re-search-forward "Name:.*\nAddress: *\\(.*\\)$" nil t)
  120.           (setq res (buffer-substring (match-beginning 1)
  121.                       (match-end 1))))
  122.       (kill-buffer (current-buffer)))
  123.     res)
  124.     host))
  125.  
  126. ;; Stolen from red gnus nntp.el
  127. (defun url-wait-for-string (regexp proc)
  128.   "Wait until string arrives in the buffer."
  129.   (let ((buf (current-buffer)))
  130.     (goto-char (point-min))
  131.     (while (not (re-search-forward regexp nil t))
  132.       (accept-process-output proc)
  133.       (set-buffer buf)
  134.       (goto-char (point-min)))))
  135.  
  136. ;; Stolen from red gnus nntp.el
  137. (defun url-open-rlogin (name buffer host service)
  138.   "Open a connection using rsh."
  139.   (if (not (stringp service))
  140.       (setq service (int-to-string service)))
  141.   (let ((proc (if url-gateway-rlogin-user-name
  142.           (start-process
  143.            name buffer "rsh"
  144.            url-gateway-rlogin-host "-l" url-gateway-rlogin-user-name
  145.            (mapconcat 'identity
  146.                   (append url-gateway-rlogin-parameters
  147.                       (list host service)) " "))
  148.         (start-process
  149.          name buffer "rsh" url-gateway-rlogin-host
  150.          (mapconcat 'identity
  151.                 (append url-gateway-rlogin-parameters
  152.                     (list host service))
  153.                 " ")))))
  154.     (set-buffer buffer)
  155.     (url-wait-for-string "^\r*200" proc)
  156.     (beginning-of-line)
  157.     (delete-region (point-min) (point))
  158.     proc))
  159.  
  160. ;; Stolen from red gnus nntp.el
  161. (defun url-open-telnet (name buffer host service)
  162.   (if (not (stringp service))
  163.       (setq service (int-to-string service)))
  164.   (save-excursion
  165.     (set-buffer (get-buffer-create buffer))
  166.     (erase-buffer)
  167.     (let ((proc (start-process name buffer "telnet" "-8"))
  168.       (case-fold-search t))
  169.       (when (memq (process-status proc) '(open run))
  170.     (process-send-string proc "set escape \^X\n")
  171.     (process-send-string proc (concat
  172.                    "open " url-gateway-telnet-host "\n"))
  173.     (url-wait-for-string url-gateway-telnet-login-prompt proc)
  174.     (process-send-string
  175.      proc (concat
  176.            (or url-gateway-telnet-user-name
  177.            (setq url-gateway-telnet-user-name (read-string "login: ")))
  178.            "\n"))
  179.     (url-wait-for-string url-gateway-telnet-password-prompt proc)
  180.     (process-send-string
  181.      proc (concat
  182.            (or url-gateway-telnet-password
  183.            (setq url-gateway-telnet-password
  184.              (funcall url-passwd-entry-func "Password: ")))
  185.            "\n"))
  186.     (erase-buffer)
  187.     (url-wait-for-string url-gateway-prompt-pattern proc)
  188.     (process-send-string
  189.      proc (concat (mapconcat 'identity
  190.                  (append url-gateway-telnet-parameters
  191.                      (list host service)) " ") "\n"))
  192.     (url-wait-for-string "^\r*Escape character.*\r*\n+" proc)
  193.     (delete-region (point-min) (match-end 0))
  194.     (process-send-string proc "\^]\n")
  195.     (url-wait-for-string "^telnet" proc)
  196.     (process-send-string proc "mode character\n")
  197.     (accept-process-output proc 1)
  198.     (sit-for 1)
  199.     (goto-char (point-min))
  200.     (forward-line 1)
  201.     (delete-region (point) (point-max)))
  202.       proc)))
  203.  
  204. ;;;###autoload
  205. (defun url-open-stream (name buffer host service)
  206.   "Open a stream to a host"
  207.   (let ((gw-method (if (and url-gateway-local-host-regexp
  208.                 (not (eq 'ssl url-gateway-method))
  209.                 (string-match
  210.                  url-gateway-local-host-regexp
  211.                  host))
  212.                'native
  213.              url-gateway-method))
  214.     ;; This hack is for OS/2 Emacs so that it will not do bogus CRLF
  215.     ;; conversions while trying to be 'helpful'
  216.     (tcp-binary-process-output-services (if (stringp service)
  217.                         (list service)
  218.                           (list service
  219.                             (int-to-string service))))
  220.  
  221.     ;; An attempt to deal with denied connections, and attempt to reconnect
  222.     (cur-retries 0)
  223.     (retry t)
  224.     (errobj nil)
  225.     (conn nil))
  226.  
  227.     ;; If the user told us to do DNS for them, do it.
  228.     (if url-gateway-broken-resolution
  229.     (setq host (url-gateway-nslookup-host host)))
  230.  
  231.     (condition-case errobj
  232.     (setq conn (case gw-method
  233.              (ssl
  234.               (open-ssl-stream name buffer host service))
  235.              ((tcp native)
  236.               (and (eq 'tcp gw-method) (require 'tcp))
  237.               (open-network-stream name buffer host service))
  238.              (socks
  239.               (socks-open-network-stream name buffer host service))
  240.              (telnet
  241.               (url-open-telnet name buffer host service))
  242.              (rlogin
  243.               (url-open-rlogin name buffer host service))
  244.              (otherwise
  245.               (error "Bad setting of url-gateway-method: %s"
  246.                  url-gateway-method))))
  247.       (error
  248.        (insert "Could not contact host: " host " / "
  249.            (if (stringp service) service (int-to-string service))
  250.            "\nAttempted using gateway method: "
  251.            (symbol-name gw-method)
  252.            "\n---- Error was: ----\n")
  253.        (setq url-current-mime-headers '(("content-type" . "text/plain")))
  254.        (display-error errobj (current-buffer))))
  255.     (if conn
  256.     (mule-inhibit-code-conversion conn))
  257.     conn))
  258.  
  259. (provide 'url-gw)
  260.